home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / share / perl5 / Debian / DictionariesCommon.pm < prev   
Text File  |  2008-06-04  |  16KB  |  560 lines
  1. #!/usr/bin/perl
  2.  
  3. package Debian::DictionariesCommon;
  4.  
  5. use base qw(Exporter);
  6. use Text::Iconv;
  7.  
  8. # List all exported symbols here.
  9. our @EXPORT_OK = qw(parseinfo updatedb loaddb
  10.             dico_checkroot
  11.             dc_get_spellchecker_params
  12.             getlibdir getsysdefault setsysdefault
  13.             getuserdefault setuserdefault
  14.             build_emacsen_support
  15.             build_jed_support
  16.             build_squirrelmail_support
  17.             );
  18. # Import :all to get everything.
  19. our %EXPORT_TAGS = (all => [@EXPORT_OK]);
  20.  
  21. my $infodir             = "/var/lib/dictionaries-common";
  22. my $cachedir            = "/var/cache/dictionaries-common";
  23. my $ispelldefault       = "ispell-default";
  24. my $sysdefault          = "/etc/dictionaries-common/$ispelldefault";
  25. my $userdefault         = "$ENV{HOME}/.$ispelldefault";
  26. my $emacsensupport      = "emacsen-ispell-dicts.el";
  27. my $jedsupport          = "jed-ispell-dicts.sl";
  28. my $squirrelmailsupport = "sqspell.php";
  29.  
  30. sub dico_checkroot {
  31.   return if ($> == 0 or ($^O eq 'interix' and $> == 197108));
  32.   die "$0: You must run this as root.\n";
  33. }
  34.  
  35. sub getlibdir {
  36.   my $class = shift;
  37.   return "$infodir/$class";
  38. }
  39.  
  40. sub mydie {
  41.   my $routine = shift;
  42.   my $errmsg = shift;
  43.   die __PACKAGE__, "($routine):E: $errmsg";
  44. }
  45.  
  46. sub parseinfo {
  47.   my $file = shift;
  48.   local $/ = "";    # IRS is global, we need 'local' here, not 'my'
  49.   open (DICT, "< $file");
  50.   my %dictionaries =
  51.     map {
  52.       s/^([^:]+):/lc ($1) . ":"/meg;  # Lower case field names
  53.       my %hash = /^([^:]+):\s*((?<!\n)[^\n]+)\s*$/mg;
  54.       map { delete $hash{$_} if ($hash{$_} =~ /^\s+$/) } keys %hash;
  55.       mydie ('parseinfo',
  56.          qq{Record in file $file does not have a "Language" entry})
  57.     if not exists $hash{language};
  58.       mydie ('parseinfo',
  59.          qq{Record in file $file does not have a "Hash-Name" entry})
  60.     if not exists $hash{"hash-name"};
  61.       my $lang = delete $hash{language};
  62.       ($lang, \%hash);
  63.     } <DICT>;
  64.   return \%dictionaries;
  65. }
  66.  
  67. # ------------------------------------------------------------------
  68. sub dc_dumpdb {
  69. # ------------------------------------------------------------------
  70. # Save %dictionaries in Data::Dumper like format. This function
  71. # should be enough for the limited needs of dictionaries-common
  72. # ------------------------------------------------------------------
  73.   my $class        = shift;
  74.   my $dictionaries = shift;
  75.   my @fullarray    = ();
  76.   my @dictarray    = ();
  77.   my $output       = "$cachedir/$class.db";
  78.   my $dictentries  = '';
  79.   my $thevalue     = '';
  80.  
  81.   foreach $thedict ( sort keys %{$dictionaries}){
  82.     $dictentries = $dictionaries->{$thedict};
  83.     @dictarray   = ();
  84.     foreach $thekey ( sort keys %{$dictentries}){
  85.       $thevalue = $dictentries->{$thekey};
  86.       # Make sure \ and ' are escaped in keyvals
  87.       $thevalue =~ s/(\\|\')/\\$1/g;
  88.       push (@dictarray,"     \'$thekey\' => \'$thevalue\'");
  89.     }
  90.     # Make sure \ and ' are escaped in dict names
  91.     $thedict =~ s/(\\|\')/\\$1/g;
  92.     push (@fullarray,
  93.       "  \'$thedict\' => \{\n" . join(",\n",@dictarray) . "\n  \}");
  94.   }
  95.  
  96.   mkdir $cachedir unless (-d $cachedir);
  97.  
  98.   open (DB,"> $output");
  99.   print DB generate_comment("### ") . "\n";
  100.   print DB "%dictionaries = (\n";
  101.   print DB join (",\n",@fullarray);
  102.   print DB "\n);\n\n1;\n";
  103.   close DB;
  104. }
  105.  
  106. # ------------------------------------------------------------------
  107. sub dc_get_spellchecker_params {
  108. # ------------------------------------------------------------------
  109. # dc_get_spellchecker_params($class,\%language)
  110. #  Get right params for $class (currently unused) and $language
  111. # ------------------------------------------------------------------
  112.   my $class       = shift;
  113.   my $language    = shift;
  114.   my $d_option    = "";
  115.   my $w_option    = "";
  116.   my $T_option    = "";
  117.   my $ispell_args = "";
  118.  
  119.   $d_option = "-d $language->{'hash-name'}"
  120.       if exists $language->{'hash-name'};
  121.   $w_option = "-w $language->{'additionalchars'}"
  122.       if exists $language->{'additionalchars'};
  123.  
  124.   if ( exists $language->{'extended-character-mode'} ){
  125.     $T_option =  $language->{'extended-character-mode'};
  126.     $T_option =~ s/^~//; # Strip leading ~ from Extended-Character-Mode.
  127.     $T_option =  '-T ' . $T_option;
  128.   }
  129.  
  130.   if ( exists $language->{'ispell-args'} ){
  131.     $ispell_args = $language->{'ispell-args'};
  132.     foreach ( split('\s+',$ispell_args) ) {
  133.       # No d_option if already in $ispell_args
  134.       $d_option = "" if /^\-d/;
  135.     }
  136.   }
  137.   return "$d_option $w_option $T_option $ispell_args";
  138. }
  139.  
  140. # ------------------------------------------------------------------
  141. sub updatedb {
  142. # ------------------------------------------------------------------
  143. # Parse info files for the given class and update class database
  144. # ------------------------------------------------------------------
  145.   my $class        = shift;
  146.   my %dictionaries = ();
  147.  
  148.   foreach my $file (<$infodir/$class/*>) {
  149.     next if $file =~ m/.*~$/;                 # Ignore ~ backup files
  150.     my $dicts = &parseinfo ("$file");
  151.     %dictionaries = (%dictionaries, %$dicts);
  152.   }
  153.   &dc_dumpdb($class,\%dictionaries);
  154. }
  155.  
  156. sub loaddb {
  157.   my $class  = shift;
  158.   my $dbfile = "$cachedir/$class.db";
  159.   if (-e $dbfile) {
  160.     do $dbfile;
  161.   }
  162.   return \%dictionaries;
  163. }
  164.  
  165. sub getdefault {
  166.   $file = shift;
  167.   if (-f $file) {
  168.     my $lang = `cat $file`;
  169.     chomp $lang;
  170.     return $lang;
  171.   }
  172.   else {
  173.     return undef;
  174.   }
  175. }
  176.  
  177. sub getuserdefault {
  178.   getdefault ($userdefault);
  179. }
  180.  
  181. sub getsysdefault {
  182.   getdefault ($sysdefault);
  183. }
  184.  
  185. sub setsysdefault {
  186.   $value = shift;
  187.   open (DEFAULT, "> $sysdefault");
  188.   print DEFAULT $value;
  189.   close DEFAULT;
  190. }
  191.  
  192. sub setuserdefault {
  193.   my $default      = getuserdefault ();
  194.   my $dictionaries = loaddb ("ispell");
  195.   my @choices      = sort keys %$dictionaries;
  196.  
  197.   if (scalar @choices == 0) {
  198.     warn "Sorry, no ispell dictionary is installed in your system.\n";
  199.     return;
  200.   }
  201.  
  202.   my $initial = -1;
  203.   if (defined $default) {
  204.     for (my $i = 0; $i < scalar @choices; $i++) {
  205.       if ($default eq $choices[$i]) {
  206.     $initial = $i;
  207.     last;
  208.       }
  209.     }
  210.   }
  211.  
  212.   open (TTY, "/dev/tty");
  213.   while (1) {
  214.     $| = 1;
  215.     print
  216.       "\nSelect your personal ispell dictionary for use with ispell-wrapper\n\n";
  217.     for ($i = 0; $i < scalar @choices; $i++) {
  218.       print "  " . ($i == $initial ? "*" : " ")
  219.          . " [" . ($i+1) . "] $choices[$i]\n";
  220.     }
  221.     print qq(\nSelect number or "q" for quit)
  222.       . ($initial != -1 ? " (* is the current default): " : ": ");
  223.     my $sel = <TTY>;
  224.     chomp $sel;
  225.     last if $sel eq "q";
  226.     if ($sel < 1 or $sel > scalar @choices) {
  227.       print qq{\nInvalid choice "$sel".\n\n};
  228.       next;
  229.     }
  230.     else {
  231.       $sel--;
  232.       open (DEFAULT, "> $userdefault");
  233.       print DEFAULT $choices[$sel];
  234.       close DEFAULT;
  235.       last;
  236.     }
  237.   }
  238.   close TTY;
  239. }
  240.  
  241. sub generate_comment {
  242.   my $commstr = shift;
  243.   my $comment = "This file is part of the dictionaries-common package.
  244. It has been automatically generated.
  245. DO NOT EDIT!";
  246.   $comment =~ s{^}{$commstr}mg;
  247.   return "$comment\n";
  248. }
  249.  
  250. # ------------------------------------------------------------------
  251. sub build_emacsen_support {
  252. # ------------------------------------------------------------------
  253. # Put info from dicts info files into emacsen-ispell-dicts.el
  254. # ------------------------------------------------------------------
  255.   my $elisp          = '';
  256.   my @classes        = ("aspell","ispell");
  257.   my %entries        = ();
  258.   my %aspell_locales = ();
  259.  
  260.   foreach $class ( @classes ){
  261.     my $dictionaries = loaddb ($class);
  262.  
  263.     foreach $k (keys %$dictionaries) {
  264.       my $lang = $dictionaries->{$k};
  265.  
  266.       next if (exists $lang->{'emacs-display'}
  267.            && $lang->{'emacs-display'} eq "no");
  268.  
  269.       my $hashname = $lang->{"hash-name"};
  270.       my $casechars = exists $lang->{casechars} ?
  271.       $lang->{casechars} : "[a-zA-Z]";
  272.       my $notcasechars = exists $lang->{"not-casechars"} ?
  273.       $lang->{"not-casechars"} : "[^a-zA-Z]";
  274.       my $otherchars = exists $lang->{otherchars} ?
  275.       $lang->{otherchars} : "[']";
  276.       my $manyothercharsp = exists $lang->{"many-otherchars"} ?
  277.       ($lang->{"many-otherchars"} eq "yes" ? "t" : "nil") : "nil";
  278.       my $ispellargs = exists $lang->{"ispell-args"} ?
  279.       ('("' . join ('" "', split (/\s+/, $lang->{"ispell-args"}))
  280.        . '")') : (qq/("-d" "/ . $lang->{"hash-name"} . qq/")/) ;
  281.       my $extendedcharactermode = exists $lang->{"extended-character-mode"} ?
  282.       ('"' . $lang->{"extended-character-mode"} . '"') : "nil";
  283.       my $codingsystem = exists $lang->{"coding-system"} ?
  284.       $lang->{"coding-system"} : "nil";
  285.       my $emacsenname = exists $lang->{"emacsen-name"} ?
  286.       $lang->{"emacsen-name"} : $hashname;
  287.  
  288.       $entries{$class}{$emacsenname} = $entries{'all'}{$emacsenname} =
  289.       ['"' . $emacsenname  . '"',
  290.        '"' . $casechars    . '"',
  291.        '"' . $notcasechars . '"',
  292.        '"' . $otherchars   . '"',
  293.        $manyothercharsp,
  294.        $ispellargs,
  295.        $extendedcharactermode,
  296.        $codingsystem];
  297.  
  298.       if ( $class eq "aspell" && exists $lang->{"aspell-locales"} ){
  299.     foreach ( split(/\s*,\s*/,$lang->{"aspell-locales"}) ){
  300.       $aspell_locales{$_} = $emacsenname;
  301.     }
  302.       }
  303.     }
  304.   }
  305.  
  306.   # Write alists of ispell and aspell only installed dicts and their properties
  307.  
  308.   foreach $class ( @classes ) {
  309.     my @class_dicts = reverse sort keys %{ $entries{$class} };
  310.     if ( scalar @class_dicts ){
  311.       $elisp .= "\n;; Adding $class dicts\n\n";
  312.       foreach ( @class_dicts ){
  313.     my $mystring = join ("\n     ",@{ $entries{$class}{$_} });
  314.     $elisp .= "(add-to-list \'debian-$class-only-dictionary-alist\n  \'($mystring))\n";
  315.       }
  316.       $elisp .= "\n";
  317.     }
  318.   }
  319.  
  320.   # Write a list of locales associated to each emacsen name
  321.  
  322.   if ( scalar %aspell_locales ){
  323.     $elisp .= "\n\n;; An alist that will try to map locales to emacsen names";
  324.     $elisp .= "\n\n(setq debian-aspell-equivs-alist \'(\n";
  325.     foreach ( sort keys %aspell_locales ){
  326.       $elisp .= "     (\"$_\" \"$aspell_locales{$_}\")\n";
  327.     }
  328.     $elisp .= "))\n";
  329.  
  330.     # Obtain here debian-aspell-dictionary, after debian-aspell-equivs-alist
  331.     # is loaded
  332.  
  333.     $elisp .="
  334. ;; Get default value for debian-aspell-dictionary. Will be used if
  335. ;; spellchecker is aspell and ispell-local-dictionary is not set.
  336. ;; We need to get it here, after debian-aspell-equivs-alist is loaded
  337.  
  338. (setq debian-aspell-dictionary (debian-get-aspell-default))\n\n";
  339.   } else {
  340.       $elisp .= "\n\n;; No emacsen-aspell-equivs entries were found\n";
  341.   }
  342.  
  343.   open (ELISP, "> $cachedir/$emacsensupport")
  344.       or die "Cannot open emacsen cache file";
  345.   print ELISP generate_comment (";;; ");
  346.   print ELISP $elisp;
  347.   close ELISP;
  348. }
  349.  
  350. # ------------------------------------------------------------------
  351. sub build_jed_support {
  352. # ------------------------------------------------------------------
  353. # Put info from dicts info files into jed-ispell-dicts.sl
  354. # ------------------------------------------------------------------
  355.  
  356.   my @classes = ("aspell","ispell");
  357.   my $slang   = generate_comment ("%%% ");
  358.  
  359.   ## The S-Lang code generated below will be wrapped in preprocessor
  360.   ## ifexists constructs, insuring that the $jedsupport file will
  361.   ## always evaluate correctly.
  362.  
  363.   foreach $class ( @classes ){
  364.     my %class_slang    = ();
  365.     my %class_slang_u8 = ();
  366.     if ( my $dictionaries = loaddb ($class) ){
  367.       foreach $k (sort keys %$dictionaries) {
  368.     my $lang = $dictionaries->{$k};
  369.     next if (exists $lang->{'jed-display'}
  370.          && $lang->{'jed-display'} eq "no");
  371.  
  372.     my $hashname = $lang->{"hash-name"};
  373.     my $additionalchars = exists $lang->{additionalchars} ?
  374.         $lang->{additionalchars} : "";
  375.     my $otherchars = exists $lang->{otherchars} ?
  376.         $lang->{otherchars} : "'";
  377.     my $emacsenname = exists $lang->{"emacsen-name"} ?
  378.         $lang->{"emacsen-name"} : $hashname;
  379.     my $extendedcharmode = exists $lang->{"extended-character-mode"} ?
  380.         $lang->{"extended-character-mode"} : "";
  381.     my $ispellargs = exists $lang->{"ispell-args"} ?
  382.         $lang->{"ispell-args"} : "";
  383.     my $codingsystem = exists $lang->{"coding-system"} ?
  384.         $lang->{"coding-system"} : "l1";
  385.  
  386.     # Strip enclosing [] from $otherchars
  387.     $otherchars =~ s/^\[//;
  388.     $otherchars =~ s/\]$//;
  389.     # Convert chars in octal \xxx representation to the character
  390.     $otherchars =~ s/\\([0-3][0-7][0-7])/chr(oct($1))/ge;
  391.     $additionalchars =~ s/\\([0-3][0-7][0-7])/chr(oct($1))/ge;
  392.  
  393.     $class_slang{$emacsenname} =
  394.         "  $class" . "_add_dictionary (\n"
  395.         . "    \"$emacsenname\",\n"
  396.         . "    \"$hashname\",\n"
  397.         . "    \"$additionalchars\",\n"
  398.         . "    \"$otherchars\",\n"
  399.         . ($class eq "ispell" ? "    \"$extendedcharmode\",\n" : "")
  400.         . "    \"$ispellargs\");";
  401.     if ( $class eq "aspell" ){
  402.       my $converter = Text::Iconv->new ($codingsystem, "utf8");
  403.       my $additionalchars_utf = $converter->convert ($additionalchars);
  404.       my $otherchars_utf = $converter->convert ($otherchars);
  405.       $class_slang_u8{$emacsenname} =
  406.           qq{    aspell_add_dictionary (
  407.       "$emacsenname",
  408.       "$hashname",
  409.       "$additionalchars_utf",
  410.       "$otherchars_utf",
  411.       "$ispellargs");};
  412.     } # if $class ..
  413.       } # foreach $k ..
  414.     } # if loaddb ..
  415.     if ( scalar keys %class_slang ){
  416.       $slang .= "\n\#ifexists $class" . "_add_dictionary\n";
  417.       if ( $class eq "aspell" ){
  418.     $slang .= "  if (_slang_utf8_ok) {\n"
  419.         . join("\n",sort values %class_slang_u8)
  420.         . "\n  } else {\n"
  421.         . join("\n",sort values %class_slang)
  422.         . "\n  }";
  423.       } else {
  424.     $slang .= join("\n",sort values %class_slang);
  425.       }
  426.       $slang .= "\n\#endif\n";
  427.     }
  428.   } # foreach $class
  429.   open (SLANG, "> $cachedir/$jedsupport")
  430.       or die "Cannot open jed cache file";
  431.   print SLANG $slang;
  432.   close SLANG;
  433. }
  434.  
  435. # ------------------------------------------------------------------
  436. sub build_squirrelmail_support {
  437. # ------------------------------------------------------------------
  438. # Build support file for squirrelmail with a list of available
  439. # dictionaries and associated spellchecker calls, in php format.
  440. # ------------------------------------------------------------------
  441.   my $class        = "ispell";
  442.   my $dictionaries = loaddb ($class);
  443.   my $php          = "<?php\n";
  444.   my @dictlist     = ();
  445.  
  446.   $php .= generate_comment ("### ");
  447.   $php .= "\$SQSPELL_APP = array (\n";
  448.   foreach ( keys %$dictionaries ){
  449.     next if m/.*[^a-z]tex[^a-z]/i;            # Discard tex variants
  450.     my $spellchecker_params =
  451.     &dc_get_spellchecker_params($class,$dictionaries->{$_});
  452.     push @dictlist, qq {  '$_' => 'ispell -a $spellchecker_params'};
  453.   }
  454.   $php .= join(",\n", @dictlist);
  455.   $php .= "\n);\n";
  456.  
  457.   open (PHP, "> $cachedir/$squirrelmailsupport")
  458.       or die "Cannot open SquirrelMail cache file";
  459.   print PHP $php;
  460.   close PHP;
  461. }
  462.  
  463. # Ensure we evaluate to true.
  464. 1;
  465.  
  466. __END__
  467.  
  468. #Local Variables:
  469. #perl-indent-level: 2
  470. #End:
  471.  
  472. =head1 NAME
  473.  
  474. Debian::DictionariesCommon.pm - dictionaries-common library
  475.  
  476. =head1 SYNOPSIS
  477.  
  478.     use Debian::DictionariesCommon q(:all)
  479.     $dictionaries = parseinfo ('/var/lib/dictionaries-common/ispell/iwolof');
  480.     loaddb ('ispell')
  481.     updatedb ('wordlist')
  482.  
  483. =head1 DESCRIPTION
  484.  
  485. Common functions for use from the dictionaries-common system.
  486.  
  487. =head1 CALLING FUNCTIONS
  488.  
  489. =over
  490.  
  491. =item C<dico_checkroot>
  492.  
  493. Check for rootness and fail if not.
  494.  
  495. =item C<build_emacsen_support>
  496.  
  497. Put info from dicts info files into emacsen-ispell-dicts.el
  498.  
  499. =item C<build_jed_support>
  500.  
  501. Put info from dicts info files into jed-ispell-dicts.sl
  502.  
  503. =item C<build_squirrelmail_support>
  504.  
  505. Build support file for squirrelmail with a list of available
  506. dictionaries and associated spellchecker calls, in php format.
  507.  
  508. =item C<$libdir = getlibdir($class)>
  509.  
  510. Return info dir for given class.
  511.  
  512. =item C<$default = getsysdefault>
  513.  
  514. Return value for system default ispell dictionary.
  515.  
  516. =item C<$libdir = getuserdefault>
  517.  
  518. Return value for user default ispell dictionary.
  519.  
  520. =item C<dc_get_spellchecker_params($class,\%language)>
  521.  
  522. Get right params for $class (currently unused) and $language
  523.  
  524. =item C<\%dictionaries = loaddb($class)>
  525.  
  526. Read class .db file and return a reference to a hash
  527. with its contents.
  528.  
  529. =item C<\%result = parseinfo($file)>
  530.  
  531. Parse given info file and return a reference to a hash with
  532. the relevant data.
  533.  
  534. =item C<setsysdefault($value)>
  535.  
  536. Set value for system default ispell dictionary.
  537.  
  538. =item C<setuserdefault>
  539.  
  540. Set value for user default ispell dictionary, after asking
  541. to select it from the available values.
  542.  
  543. =item C<updatedb($class)>
  544.  
  545. Parse info files for given class and update class .db
  546. file under dictionaries-common cache dir.
  547.  
  548. =back
  549.  
  550. =head1 SEE ALSO
  551.  
  552. Debian dictionaries-common policy.
  553.  
  554. =head1 AUTHORS
  555.  
  556.  Rafael Laboissiere
  557.  Agustin Martin
  558.  
  559. =cut
  560.